home *** CD-ROM | disk | FTP | other *** search
/ Disc to the Future 2 / Disc to the Future Part II Programmer's Reference (Wayzata Technology)(6013)(1992).bin / MAC / OTHER_LA / YERK__ / TOOLBOX_ / READPORT.1 < prev    next >
Text File  |  1990-08-15  |  3KB  |  117 lines
  1. \ 6.10.87    rfl    modified to support backspace and paste
  2. \ 6.3.87    rfl Sends a text file to a Forth Board. Tabs are converted to
  3. \                spaces.
  4.  
  5. \ 4/19/87    rfl    removed most of switcher setup to relect telescope arch.
  6. \                this means no outputqueue and no polling
  7. \ 10.1.87    rfl added next: fevent to timeoutwait
  8. \ 10.8.87    rfl above fix caused problems with searcher on abort.... removed
  9. \ 1.1.88    rfl    general cleanup
  10. \ 6.22.88    rfl changed to class xPort for same methods to printer
  11. \ 7.1.88    rfl    took out next: fevent because of suspected problems with dlg
  12. \ 7.11.88    rfl    changed nullproc to assembly and took out pnullproc
  13. \ 9.17.88    rfl    remove link and endlink
  14. \ 8.13.90    rfl    modified term and removed ackword stuff
  15.  
  16. create nullProc $ 4e75 w,
  17.  
  18. 0 value charflag
  19. 0 variable theChar
  20.  
  21. :PROC doChr true -> charflag ;PROC
  22.  
  23. \ necessary to scroll since '13 emit' is not identical to 'cr'
  24. ( char -- )
  25. : .keys 4 tmode
  26.     CASE
  27.                 8 OF (bs) ENDOF
  28.                 0 12 RANGEOF ENDOF
  29.                 13  OF  cr ENDOF
  30.                 emit 0
  31.         ENDCASE 0 tmode ;
  32.  
  33. \ 0 variable ackWord  \ just a location to throw in acknowledgments
  34.  
  35. :CLASS ReadPort <super port
  36.  
  37.     timer    myTimer
  38.     int        TimeOutTime    \ a value of 4 is marginal, 5 seems to work ok
  39.     var        myAction
  40.     var        myNullProcCfa
  41.  
  42.   :M putTimeOut: put: timeOutTime ;M
  43.  
  44.   :M actions: put: myAction ;M
  45.  
  46.   :M putProc: put: myNullProcCfa ;M
  47.  
  48.   :M killRead: get: myNullProcCfa +base ^base 24 + ! kill: super drop ;M
  49.  
  50.   :M classInit: nullcfa put: myAction 6 put: timeOutTime ;M
  51.  
  52. \ waits for an acknowledge or times out. 'time' is in 60ths of a second
  53. \ returns non-zero if an error condition exists
  54.   :M timeOutWait: { time \ flag -- tf } 
  55.     start: myTimer false -> flag
  56.     BEGIN get: myTimer time >
  57.           IF  killread: self exec: myAction true -> flag THEN
  58. \          next: fevent IF 2drop THEN
  59.           result: self not 
  60.     UNTIL flag ;M
  61.  
  62. \ ( -- tf)
  63. \  :M waitForAck: get: myNullProcCfa
  64. \    ackword 1 readnw: self drop get: timeOutTime timeoutwait: self ;M
  65.  
  66.   :M term: { oPort \ myChar -- } 0 -> myChar 0 -> charflag
  67.         BEGIN result: self 0=
  68.             IF charFlag 0=
  69.                 IF 'c doChr theChar 1 readnw: self drop
  70.                 ELSE 0 -> charflag thechar c@ .keys
  71.                 THEN
  72.             ELSE result: self 0<
  73.                 IF result: self . abort" =read error" THEN
  74.             THEN
  75.             ?terminal
  76.             IF key -> myChar myChar ascii | <>
  77.                 IF myChar 8 =
  78.                     IF 127 ELSE myChar THEN
  79.                         put: oPort
  80.                 THEN
  81.             THEN
  82.             myChar ascii | =
  83.         UNTIL kill: self drop  ;M
  84.  
  85. ;CLASS
  86.  
  87. port iwout                port pwout
  88. 0 1 init: iwout            1 1 init: pwout
  89. 2 8 0 config: iwout        2 8 0 config: pwout
  90. 2400 baud: iwout        19200 baud: pwout
  91.  
  92. readPort iwin            \ instantiate input port
  93. 0 0 init: iwin            \ modem port
  94. 2 8 0 config: iwin        \ 2 stop, 8 data, no parity
  95. 2400 baud: iwin
  96. 'c nullProc putProc: iwin
  97.  
  98. ReadPort pwin            \ instantiate input port
  99. 1 0 init: pwin            \ printer port
  100. 2 8 0 config: pwin        \ 2 stop, 8 data, no parity
  101. 19200 baud: pwin
  102. 'c NullProc putProc: pwin
  103.  
  104.  
  105. : term  iwout term: iwin ;
  106. : pterm pwout term: pwin ;
  107.  
  108. : iOpen open: iwout open: iwin reset: iwin 2drop ;
  109. : pOpen open: pwout open: pwin reset: pwin 2drop ;
  110. : start iOpen pOpen ;
  111.  
  112.         
  113. : pWrite write: pwout drop ;
  114. : pWriteCr pWrite 13 put: pwout ;
  115. : crp 13 put: pwout ;
  116.  
  117.